Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE09/CODERS/STRFUNC.PAS

Pascal/Delphi Source File | 1995-11-20 | 10.3 KB | 401 lines

unit StrFunc ;
(*****) interface (*******************************)

uses
  ChrConst ;

const
  MaxPasString = SizeOf( string ) - 1 ;
  NULLSTR = '' ;

function PadLeft( Strng, Padding : string ; Count : byte ) : string ;
(* pad left end of input string with Padding Count times *)

function PadRight( Strng, Padding : string ; Count : byte ) : string ;
(* pad right end of input string with Padding Count times *)

function PadBoth( Strng, Padding : string ; Count : byte ) : string ;
(* pad both ends of input string with Padding Count times *)

function InStr( SubStr, Strng : string ; StartIndex : byte ) : byte ;
(* simulates BASIC's InStr function with an offset *)

function InStrCt( SubStr, Strng : string ; StartIndex : byte ) : byte ;
(* returns the number of instances of SubStr in Strng beginning *)
(* at offset StartIndex                                         *)

function Left( Strng : string ; NumChars : byte ) : string ;
(* simulates BASIC's Left$ function *)

function Right( Strng : string ; NumChars : byte ) : string ;
(* simulates BASIC's Right$ function *)

function Mid( Strng : string ; Start, Count : byte ) : string ;
(* simulates BASIC's Mid$ function *)

function PosMid( Strng : string ; First, Last : byte ) : string ;
(* simulates True BASIC's string extraction by indices *)

function DnCase( C  : char )  : char ;
(*  returns Lowercase of C; meant to parallel built in UpCase function; *)
(*  naive about diacritical high byte characters, only translates A..Z  *)

function StrRep( var S : string ; ch1, ch2 : char ) : word ;
(* replaces all occurrences of ch1 in S with ch2 *)
(* returns number of replacements made, 0 if no  *)
(* replacements are made                         *)

function Replace( var S : string ; Orig, Rep : string ; Count : byte ) : word ;
(* replaces all occurences of Orig string in S with Rep string   *)
(* returns the number of replacements made, 0 if no replacements *)
(* were made                                                     *)

function Chop( S : string ; Len : byte ) : string ;
(* trim a string to a specified length *)

function LeftChop( S : string ; Len : byte ) : string ;
(* return rightmost characters of a string *)

function Trim( S : string ; c : char ) : string ;
(* trim any examples of character 'c' from beginning and ending of string *)

function LTrim( S : string ; c : char ) : string ;
(* trim any examples of character 'c' from beginning of string *)

function RTrim( S : string ; c : char ) : string ;
(* trim any examples of character 'c' from end of string *)

function LoCase( Ch : char ) : char ;
function LowerCase( const S : string ) : string ;
function UpperCase( const S : string ) : string ;



(*****) implementation (**************************)

function PadLeft( Strng, Padding : string ; Count : byte ) : string ;
(* pad left end of input string with Padding Count times *)
var
  S : string ;
  i : byte ;
begin
  S := Strng ;
  for i := 1 to Count do
    S := Padding + S ;
  PadLeft := S ;
end ;

function PadRight( Strng, Padding : string ; Count : byte ) : string ;
(* pad right end of input string with Padding Count times *)
var
  S : string ;
  i : byte ;
begin
  S := Strng ;
  for i := 1 to Count do
    S := S + Padding ;
  PadRight := S ;
end ;

function PadBoth( Strng, Padding : string ; Count : byte ) : string ;
(* pad both ends of input string with Padding Count times *)
var
  S : string ;
begin (* function -- PadStr *)
  S := Strng ;
  S := PadLeft( S, Padding, Count ) ;
  S := PadRight( S, Padding, Count ) ;
  PadBoth := S ;
end   (* function -- PadStr *) ;


function InStr( SubStr, Strng : string ; StartIndex : byte ) : byte ;
(* simulates BASIC's InStr function with an offset *)
var
  StrPos : byte ;
begin
(*  argument checking *)

  if ( Strng = NULLSTR ) or ( SubStr = NULLSTR ) then
  begin
    InStr := 0 ;
    Exit ;
  end (* if *) ;

  StrPos := 0 ;

(*  Main body of procedure *)
  if ( StartIndex > 0 ) and ( StartIndex <= Length( Strng )) then
  begin
  (* clip leading part of the string Strng? *)
    if StartIndex > 1 then
      Delete( Strng, 1, StartIndex - 1 ) ;
    StrPos := Pos( SubStr, Strng ) ;
    if ( StrPos > 0 ) and ( StartIndex > 1 ) then
      Inc( StrPos, StartIndex - 1 ) ;
  end (* if *) ;

  InStr := StrPos ;
end (* function InStr *) ;

function Left( Strng : string ; NumChars : byte ) : string ;
(* simulates BASIC's Left$ function *)
begin
  Left := Copy( Strng, 1, NumChars ) ;
end (* function Left *) ;

function Right( Strng : string ; NumChars : byte ) : string ;
(* simulates BASIC's Right$ function *)
var
  StartPos : byte ;
begin
  if NumChars > Length( Strng ) then
    StartPos := 1
  else
    StartPos := Length( Strng ) - NumChars + 1 ;
  Right := Copy( Strng, StartPos, Length( Strng )) ;
end ;

function Mid( Strng : string ; Start, Count : byte ) : string ;
(* simulates BASIC's Mid$ function *)
begin
  Mid := Copy( Strng, Start, Count ) ;
end ;

function PosMid( Strng : string ; First, Last : byte ) : string ;
(* simulates True BASIC's string extraction by indices *)
var
  EndPos : byte ;
begin
  (* argument checking *)
  if ( Strng = NULLSTR ) or ( Last < First ) then
  begin
    PosMid := NULLSTR ;
    Exit ;
  end (* if *) ;

  EndPos := Last - First + 1 ;
  PosMid := Copy( Strng, First, EndPos ) ;
end ;

function DnCase( C : char ) : char ;
(* returns Lowercase of C; meant to parallel built in UpCase function; *)
(* naive about diacritical high byte characters, only translates A..Z  *)
const
  lcArray : array ['A'..'Z'] of char = 'abdcefghijklmnopqrstuvwxyz' ;
begin
(*  LCase := Chr( Ord( C ) - Ord( 'A' ) + Ord( 'a' )) ; *)
  if not ( C in ['A'..'Z']) then
    DnCase := C
  else
    DnCase := lcArray[C] ;
end ;

function StrRep( var S : string ; ch1, ch2 : char ) : word ;
(* replaces all occurrences of ch1 in S with ch2 *)
(* returns number of replacements made, 0 if no  *)
(* replacements are made                         *)
var
  Ct, i : word ;
begin
  Ct := 0 ;
  for i := 1 to Length( S ) do
    if S[i] = ch1 then
    begin
      S[i] := ch2 ;
      Inc( Ct ) ;
    end ;
  StrRep := Ct ;
end ;

function InStrCt( SubStr, Strng : string ; StartIndex : byte ) : byte ;
(* returns the number of instances of SubStr in Strng beginning *)
(* at offset StartIndex                                         *)
var
  Index, Len, SubLen, Ct, Loc : byte ;
begin
  if Strng = '' then
  begin
    InStrCt := 0 ;
    Exit ;
  end ;

  Loc := InStr( SubStr, Strng, StartIndex ) ;
  if Loc = 0 then
  begin
    InStrCt := 0 ;
    Exit ;
  end ;

  Len := Length( Strng ) ;
  SubLen := Length( SubStr ) ;
  Index := Loc ;
  Ct := 1 ;

  while ( Index <= Len ) and ( Loc <> 0 ) do
  begin
    Loc := InStr( SubStr, Strng, Index + SubLen ) ;
    if Loc <> 0 then
    begin
      Inc( Ct ) ;
      Index := Loc ;
    end ;
  end ;
  InStrCt := Ct ;
end ;


function Replace( var S : string ; Orig, Rep : string ; Count : byte ) : word ;
(* replaces Count occurences of Orig string in S with Rep string *)
(* returns the number of replacements made, 0 if no replacements *)
(* were made                                                     *)
var
  OLen, RLen, Ct, Loc : byte ;
  Fore, Aft : string ;
begin
  if S = '' then
  begin
    Replace := 0 ;
    Exit ;
  end ;

  Loc := InStr( Orig, S, 1 ) ;
  if Loc = 0 then
  begin
    Replace := 0 ;
    Exit ;
  end ;

  OLen := Length( Orig ) ;
  RLen := Length( Rep ) ;
  Ct := 0 ;
  Aft := S ;
  Fore := '' ;
  repeat
    Fore := Fore + Left( Aft, Loc - 1 ) + Rep ;
    Aft := Mid( Aft, Loc + OLen, Length( Aft )) ;
    Inc( Ct ) ;
    Loc := InStr( Orig, Aft, 1 ) ;
  until ( Loc = 0 ) or ( Ct = Count ) ;
  S := Fore + Aft ;
  Replace := Ct ;
end ;

function Chop( S : string ; Len : byte ) : string ;
(* trim a string to a specified length *)
var
  Temp : string ;
begin
  Temp := S ;
  if Length( Temp ) > Len then
    Temp[0] := Chr( Len ) ;
  Chop := Temp ;
end ;

function LeftChop( S : string ; Len : byte ) : string ;
(* return rightmost characters of a string *)
var
  Temp : string ;
begin
  Temp := S ;
  if Length( Temp ) > Len then
  begin
    Move( Temp[Succ( Length( Temp ) - Len )],
      S[1], Len ) ;
    Temp[0] := Chr( Len ) ;
  end ;
  LeftChop := Temp ;
end ;

function Trim( S : string ; c : char ) : string ;
(* trim any examples of character 'c' from beginning and ending of string *)
var
  Temp : string ;
begin
  Temp := S ;
  Temp := LTrim( Temp, c ) ;
  Temp := RTrim( Temp, c ) ;
  Trim := Temp ;
end ;

function LTrim( S : string ; c : char ) : string ;
(* trim any examples of character 'c' from beginning of string *)
var
  Temp : string ;
  P : byte ;
begin
  P := 1 ;
  Temp := S ;
  while ( Temp[P] = C ) and ( P <= Length( Temp )) do
    Inc( P ) ;
  case P of
    0 : Temp[0] := #0 ; (* string was 255 of C! *)
    1 : (* not found, do nothing *) ;
    else
      Move( Temp[P], Temp[1], Succ( Length( S ) - P )) ;
      Dec( Temp[0], Pred( P )) ;
  end (* case *) ;
  LTrim := Temp ;
end ;


function RTrim( S : string ; c : char ) : string ;
(* trim any examples of character 'c' from end of string *)
var
  Temp : string ;
begin
  Temp := S ;
  while Temp[Length( Temp )] = C do
    Dec( Temp[0] ) ;
  RTrim := Temp ;
end ;

function LoCase( Ch : char ) : char ;
const
  LoArray : array ['A'..'Z'] of char =
    'abcdefghijklmnopqrstuvwxyz' ;
begin
  if Ch in ['A'..'Z'] then
    Ch := LoArray[Ch] ;
end ;

function LowerCase( const S : string ) : string ;
var
  i : byte ;
  Temp : string ;
begin
  for i := 1 to Length( S ) do
    if S[i] in ['A'..'Z'] then
      Temp[i] := LoCase( S[i] )
    else
      Temp[i] := S[i];
  Temp[0] := Chr( Length( S )) ;
  LowerCase := Temp ;
end ;

function UpperCase( const S : string ) : string ;
var
  i : byte ;
  Temp : string ;
begin
  for i := 1 to Length( S ) do
    if S[i] in ['a'..'z'] then
      Temp[i] := UpCase( S[i] )
    else
      Temp[i] := S[i];
  Temp[0] := Chr( Length( S )) ;
  UpperCase := Temp ;

end ;


{$ifdef ver80 }
initialization
{$else}
begin
{$endif}
    (* unit strfunc -- initialization code *)
  (* NONE *)
end (* unit strfunc -- initialization code *) .